home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / LOOKPRM.C < prev    next >
C/C++ Source or Header  |  1992-01-20  |  13KB  |  431 lines
  1. /* -*-C-*-
  2.  
  3. $Header: /scheme/src/microcode/RCS/lookprm.c,v 1.8 1992/01/20 13:26:19 jinx Exp $
  4.  
  5. Copyright (c) 1988-1992 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. */
  34.  
  35. /* This file contains environment manipulation primitives.
  36.    It makes heavy use of procedures in lookup.c */
  37.  
  38. #include "scheme.h"
  39. #include "locks.h"
  40. #include "trap.h"
  41. #include "lookup.h"
  42. #include "prims.h"
  43.  
  44. /* NOTE:
  45.    Although this code has been parallelized, it has not been
  46.    exhaustively tried on a parallel processor.  There are probably
  47.    various race conditions that have to be thought about carefully.
  48.  */
  49.  
  50. /* Utility macros */
  51.  
  52. #define VALID_ENVIRONMENT_P(env)                    \
  53.   ((OBJECT_TYPE (env) == TC_ENVIRONMENT) ||                \
  54.    ((OBJECT_TYPE (env) == GLOBAL_ENV) &&                \
  55.     (OBJECT_DATUM (env) == GO_TO_GLOBAL)))
  56.  
  57. /* This used to be more paranoid, and check for interned symbols,
  58.    rather than normal symbols.  Does it matter?
  59.  */
  60.  
  61. #define lookup_primitive_type_test()                    \
  62. do                                    \
  63. {                                    \
  64.   CHECK_ARG(1, ENVIRONMENT_P);                        \
  65.   CHECK_ARG(2, SYMBOL_P);                        \
  66. } while (0)
  67.  
  68. #define lookup_primitive_action(action)                    \
  69. {                                    \
  70.   long result;                                \
  71.                                     \
  72.   result = (action);                            \
  73.   if (result != PRIM_DONE)                        \
  74.   {                                    \
  75.     if (result == PRIM_INTERRUPT)                    \
  76.       signal_interrupt_from_primitive();                \
  77.     else                                \
  78.       signal_error_from_primitive(result);                \
  79.   }                                    \
  80. }
  81.  
  82. #define lookup_primitive_end(value, action)                \
  83. {                                    \
  84.   lookup_primitive_action(action);                    \
  85.   PRIMITIVE_RETURN(value);                        \
  86. }
  87.  
  88. #define standard_lookup_primitive(action)                \
  89. {                                    \
  90.   lookup_primitive_type_test();                        \
  91.   lookup_primitive_end(Val, action);                    \
  92.   /*NOTREACHED*/                            \
  93. }
  94.  
  95. /* (LEXICAL-ASSIGNMENT ENVIRONMENT SYMBOL VALUE)
  96.    Sets the value of the variable with the name given in SYMBOL, as
  97.    seen in the lexical ENVIRONMENT, to the specified VALUE.
  98.    Returns the previous value.
  99.  
  100.    It's indistinguishable from evaluating
  101.    (set! <symbol> <value>) in <environment>.
  102. */
  103.  
  104. DEFINE_PRIMITIVE ("LEXICAL-ASSIGNMENT", Prim_lexical_assignment, 3, 3, 0)
  105. {
  106.   PRIMITIVE_HEADER (3);
  107.  
  108.   standard_lookup_primitive(Symbol_Lex_Set(ARG_REF (1),
  109.                        ARG_REF (2), ARG_REF (3)));
  110. }
  111.  
  112. /* (LEXICAL-REFERENCE ENVIRONMENT SYMBOL)
  113.    Returns the value of the variable with the name given in SYMBOL,
  114.    as seen in the lexical ENVIRONMENT.
  115.  
  116.    Indistinguishable from evaluating <symbol> in <environment>.
  117. */
  118.  
  119. DEFINE_PRIMITIVE ("LEXICAL-REFERENCE", Prim_lexical_reference, 2, 2, 0)
  120. {
  121.   PRIMITIVE_HEADER (2);
  122.  
  123.   standard_lookup_primitive(Symbol_Lex_Ref(ARG_REF (1), ARG_REF (2)));
  124. }
  125.  
  126. /* (LOCAL-REFERENCE ENVIRONMENT SYMBOL)
  127.    Identical to LEXICAL_REFERENCE, here for histerical reasons.
  128. */
  129.  
  130. DEFINE_PRIMITIVE ("LOCAL-REFERENCE", Prim_local_reference, 2, 2, 0)
  131. {
  132.   PRIMITIVE_HEADER (2);
  133.  
  134.   standard_lookup_primitive(Symbol_Lex_Ref(ARG_REF (1), ARG_REF (2)));
  135. }
  136.  
  137. /* (LOCAL-ASSIGNMENT ENVIRONMENT SYMBOL VALUE)
  138.    Should be called LEXICAL-DEFINE.
  139.  
  140.    If the variable specified by SYMBOL already exists in the
  141.    lexical ENVIRONMENT, then its value there is changed to VALUE.
  142.    Otherwise a new binding is created in that environment linking
  143.    the specified variable to the value.  Returns SYMBOL.
  144.  
  145.    Indistinguishable from evaluating
  146.    (define <symbol> <value>) in <environment>. */
  147.  
  148. DEFINE_PRIMITIVE ("LOCAL-ASSIGNMENT", Prim_local_assignment, 3, 3, 0)
  149. {
  150.   PRIMITIVE_HEADER (3);
  151.   standard_lookup_primitive
  152.     (Local_Set ((ARG_REF (1)), (ARG_REF (2)), (ARG_REF (3))));
  153. }
  154.  
  155. /* (LEXICAL-UNASSIGNED? ENVIRONMENT SYMBOL)
  156.    Returns #T if the variable corresponding to SYMBOL is bound
  157.    but has the special UNASSIGNED value in ENVIRONMENT.  Returns
  158.    #F otherwise.  Does a complete lexical search for SYMBOL
  159.    starting in ENVIRONMENT.
  160.    The special form (unassigned? <symbol>) is built on top of this. */
  161.  
  162. DEFINE_PRIMITIVE ("LEXICAL-UNASSIGNED?", Prim_unassigned_test, 2, 2, 0)
  163. {
  164.   extern long EXFUN (Symbol_Lex_unassigned_p, (SCHEME_OBJECT, SCHEME_OBJECT));
  165.   PRIMITIVE_HEADER (2);
  166.   standard_lookup_primitive
  167.     (Symbol_Lex_unassigned_p ((ARG_REF (1)), (ARG_REF (2))));
  168. }
  169.  
  170. /* (LEXICAL-UNBOUND? ENVIRONMENT SYMBOL)
  171.    Returns #T if the variable corresponding to SYMBOL has no
  172.    binding in ENVIRONMENT.  Returns #F otherwise.  Does a complete
  173.    lexical search for SYMBOL starting in ENVIRONMENT.
  174.    The special form (unbound? <symbol>) is built on top of this. */
  175.  
  176. DEFINE_PRIMITIVE ("LEXICAL-UNBOUND?", Prim_unbound_test, 2, 2, 0)
  177. {
  178.   extern long EXFUN (Symbol_Lex_unbound_p, (SCHEME_OBJECT, SCHEME_OBJECT));
  179.   PRIMITIVE_HEADER (2);
  180.   standard_lookup_primitive
  181.     (Symbol_Lex_unbound_p ((ARG_REF (1)), (ARG_REF (2))));
  182. }
  183.  
  184. /* (LEXICAL-UNREFERENCEABLE? ENVIRONMENT SYMBOL)
  185.    Returns #T if evaluating <symbol> in <environment> would cause
  186.    a variable lookup error (unbound or unassigned).
  187. */
  188.  
  189. DEFINE_PRIMITIVE ("LEXICAL-UNREFERENCEABLE?", Prim_unreferenceable_test, 2, 2, 0)
  190. {
  191.   long Result;
  192.   PRIMITIVE_HEADER (2);
  193.  
  194.   lookup_primitive_type_test();
  195.   Result = Symbol_Lex_Ref(ARG_REF (1), ARG_REF (2));
  196.   switch (Result)
  197.   {
  198.     case PRIM_DONE:
  199.       PRIMITIVE_RETURN (SHARP_F);
  200.  
  201.     case PRIM_INTERRUPT:
  202.       signal_interrupt_from_primitive();
  203.       /*NOTREACHED*/
  204.  
  205.     case ERR_UNASSIGNED_VARIABLE:
  206.     case ERR_UNBOUND_VARIABLE:
  207.       PRIMITIVE_RETURN(SHARP_T);
  208.  
  209.     default:
  210.       signal_error_from_primitive(Result);
  211.   }
  212.   /*NOTREACHED*/
  213. }
  214.  
  215. SCHEME_OBJECT
  216. DEFUN (extract_or_create_cache, (frame, sym),
  217.        SCHEME_OBJECT frame
  218.        AND SCHEME_OBJECT sym)
  219. {
  220.   extern SCHEME_OBJECT compiler_cache_variable[];
  221.   extern long EXFUN (compiler_cache,
  222.              (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT,
  223.               SCHEME_OBJECT, long, long, Boolean));
  224.   SCHEME_OBJECT *cell, value;
  225.   long trap_kind, result;
  226.  
  227.   cell = deep_lookup(frame, sym, compiler_cache_variable);
  228.   value = MEMORY_FETCH (cell[0]);
  229.   if (REFERENCE_TRAP_P(value))
  230.   {
  231.     get_trap_kind(trap_kind, value);
  232.     switch (trap_kind)
  233.     {
  234.       case TRAP_UNBOUND:
  235.       case TRAP_UNBOUND_DANGEROUS:
  236.         signal_error_from_primitive(ERR_UNBOUND_VARIABLE);
  237.  
  238.       case TRAP_COMPILER_CACHED:
  239.       case TRAP_COMPILER_CACHED_DANGEROUS:
  240.     return (FAST_MEMORY_REF (value, TRAP_EXTRA));
  241.  
  242.       /* This should list the traps explicitely */
  243.       default:
  244.         break;
  245.     }
  246.   }
  247.   result = compiler_cache(cell, frame, sym, SHARP_F, 0,
  248.               TRAP_REFERENCES_LOOKUP, true);
  249.   if (result != PRIM_DONE)
  250.   {
  251.     if (result == PRIM_INTERRUPT)
  252.       signal_interrupt_from_primitive();
  253.     else
  254.       signal_error_from_primitive(result);
  255.   }
  256.   value = MEMORY_FETCH (cell[0]);
  257.   return (FAST_MEMORY_REF (value, TRAP_EXTRA));
  258. }
  259.  
  260. void
  261. DEFUN (error_bad_environment, (arg), long arg)
  262. {
  263.   if (OBJECT_TYPE (ARG_REF(arg)) == GLOBAL_ENV)
  264.     error_bad_range_arg(arg);
  265.   else
  266.     error_wrong_type_arg(arg);
  267.   /*NOTREACHED*/
  268. }
  269.  
  270. /* (ENVIRONMENT-LINK-NAME <env1> <env2> <symbol>)
  271.    <symbol> must be locally undefined in <env1>, and defined in <env2>.
  272.    It defines <symbol> in <env1> and makes it share its value cell with
  273.    <symbol> in <env2>.
  274.  
  275.    This code returns #t if it succeeds, or the following errors
  276.    (besides type and range errors) with the following meanings:
  277.  
  278.    - ERR_UNBOUND_VARIABLE:
  279.       <symbol> is unbound in <env2>.
  280.  
  281.    - ERR_BAD_SET:
  282.       <symbol> is bound locally in <env1>.
  283.  
  284.    - ERR_BAD_FRAME:
  285.       Inconsistency in the code.  Bad value found.
  286.  
  287.    - ILLEGAL_REFERENCE_TRAP:
  288.       A bad reference trap was found.
  289.  
  290.    *UNDEFINE*: If undefine is ever implemented, the code below may be
  291.    affected.  It will have to be rethought.
  292.  
  293.    NOTE: The following procedure and extract_or_create_cache have NOT
  294.    been parallelized.  They need thinking.
  295. */
  296.  
  297. DEFINE_PRIMITIVE ("ENVIRONMENT-LINK-NAME", Prim_environment_link_name, 3, 3, 0)
  298. {
  299.   extern SCHEME_OBJECT * EXFUN (scan_frame,
  300.                 (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *,
  301.                  long, Boolean));
  302.   SCHEME_OBJECT target, source, sym;
  303.   SCHEME_OBJECT cache, *cell, *value_cell;
  304.   PRIMITIVE_HEADER (3);
  305.  
  306.   target = ARG_REF (1);
  307.   source = ARG_REF (2);
  308.   sym = ARG_REF (3);
  309.  
  310.   if (!SYMBOL_P(sym))
  311.     error_wrong_type_arg(3);
  312.  
  313.   if (!VALID_ENVIRONMENT_P(source))
  314.     error_bad_environment(2);
  315.  
  316.   if (!VALID_ENVIRONMENT_P(target))
  317.     error_bad_environment(1);
  318.  
  319.   cache = extract_or_create_cache(source, sym);
  320.  
  321.   if (OBJECT_TYPE (target) == GLOBAL_ENV)
  322.   {
  323.     long trap_kind;
  324.     SCHEME_OBJECT value;
  325.  
  326.     cell = MEMORY_LOC (sym, SYMBOL_GLOBAL_VALUE);
  327.     value = MEMORY_FETCH (cell[0]);
  328.  
  329.     if (!REFERENCE_TRAP_P(value))
  330.       /* The variable is bound! */
  331.       signal_error_from_primitive(ERR_BAD_SET);
  332.  
  333.     get_trap_kind(trap_kind, value);
  334.     switch(trap_kind)
  335.     {
  336.       case TRAP_UNBOUND:
  337.       case TRAP_UNBOUND_DANGEROUS:
  338.       {
  339.     /* Allocate new trap object. */
  340.     fast SCHEME_OBJECT *trap;
  341.  
  342.     Primitive_GC_If_Needed(2);
  343.     trap = Free;
  344.     Free += 2;
  345.     trap[0] = LONG_TO_UNSIGNED_FIXNUM((trap_kind == TRAP_UNBOUND) ?
  346.                        TRAP_COMPILER_CACHED :
  347.                        TRAP_COMPILER_CACHED_DANGEROUS);
  348.     trap[1] = cache;
  349.     MEMORY_STORE (cell[0], MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, trap));
  350.     PRIMITIVE_RETURN(SHARP_T);
  351.       }
  352.  
  353.       case TRAP_COMPILER_CACHED:
  354.       case TRAP_COMPILER_CACHED_DANGEROUS:
  355.       {
  356.     if (MEMORY_REF (MEMORY_REF (value, TRAP_EXTRA), TRAP_EXTENSION_CELL) !=
  357.         UNBOUND_OBJECT)
  358.     {
  359.       /* It is bound */
  360.  
  361.       signal_error_from_primitive(ERR_BAD_SET);
  362.     }
  363.     lookup_primitive_action(compiler_uncache(cell, sym));
  364.     value_cell = MEMORY_LOC (cache, TRAP_EXTENSION_CELL);
  365.     lookup_primitive_action
  366.       (compiler_recache(shadowed_value_cell, value_cell, target,
  367.                 sym, (MEMORY_FETCH (value_cell[0])), false, true));
  368.     MEMORY_SET (value, TRAP_EXTRA, cache);
  369.     PRIMITIVE_RETURN(SHARP_T);
  370.       }
  371.  
  372.       case TRAP_DANGEROUS:
  373.       case TRAP_UNASSIGNED:
  374.       case TRAP_UNASSIGNED_DANGEROUS:
  375.       case TRAP_FLUID:
  376.       case TRAP_FLUID_DANGEROUS:
  377.         /* The variable is bound! */
  378.         signal_error_from_primitive(ERR_BAD_SET);
  379.  
  380.       default:
  381.         signal_error_from_primitive(ERR_ILLEGAL_REFERENCE_TRAP);
  382.     }
  383.   }
  384.  
  385.   else
  386.   {
  387.     SCHEME_OBJECT *trap;
  388.  
  389.     cell = scan_frame(target, sym, fake_variable_object, 0, true);
  390.  
  391.     /* Is it bound? */
  392.  
  393.     if ((cell != ((SCHEME_OBJECT *) NULL)) &&
  394.     (MEMORY_FETCH (cell[0]) != DANGEROUS_UNBOUND_OBJECT))
  395.     {
  396.       signal_error_from_primitive(ERR_BAD_SET);
  397.     }
  398.  
  399.     /* Allocate new trap object. */
  400.  
  401.     Primitive_GC_If_Needed(2);
  402.     trap = Free;
  403.     Free += 2;
  404.     trap[1] = cache;
  405.  
  406.     lookup_primitive_action(extend_frame(target, sym, SHARP_F, target, false));
  407.  
  408.     if (cell == ((SCHEME_OBJECT *) NULL))
  409.     {
  410.       trap[0] = LONG_TO_UNSIGNED_FIXNUM(TRAP_COMPILER_CACHED);
  411.       cell = scan_frame(target, sym, fake_variable_object, 0, true);
  412.       if (cell == ((SCHEME_OBJECT *) NULL))
  413.     signal_error_from_primitive(ERR_BAD_FRAME);
  414.     }
  415.     else
  416.     {
  417.       trap[0] = LONG_TO_UNSIGNED_FIXNUM(TRAP_COMPILER_CACHED_DANGEROUS);
  418.     }
  419.  
  420.     if (MEMORY_FETCH (cell[0]) != DANGEROUS_UNBOUND_OBJECT)
  421.       signal_error_from_primitive(ERR_BAD_FRAME);
  422.  
  423.     value_cell = MEMORY_LOC (cache, TRAP_EXTENSION_CELL);
  424.     lookup_primitive_action
  425.       (compiler_recache(shadowed_value_cell, value_cell, target,
  426.             sym, MEMORY_FETCH (value_cell[0]), false, true));
  427.     MEMORY_STORE (cell[0], MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, trap));
  428.     PRIMITIVE_RETURN(SHARP_T);
  429.   }
  430. }
  431.